;; st.lsp
;; jrlf 2012-10-06
;; Story Trace -- Compose and organize storylines for plots.

;; Copyright (C) 2013  Jos'h Fuller

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.


(load (append (env "NEWLISPDIR") "/guiserver.lsp"))

; h2. Globals

(constant  'program-name "Story Trace"  'program-version "v2013-010")

(setq next-id   0
      current   nil
      gui-state 'waiting
      gui-start nil
      colours   (list gs:white gs:red gs:orange gs:yellow gs:green gs:blue)
      )
(new Tree 'nodes)


; h2. Utilities

; h3. General

(define (in item items)
  "( item items -- f) Find item in list, or not."
  (not (nil? (find item items))))

; h3. GUI Functions

(define (gs:nix)
  "( * --) Swallows all input and does nothing. Use to null events."
  )

(define (gs:mon)
  "( * --) Print out arguments. Otherwise does nothing."
  (println "MON:" (args))
)

(define (gs:delete-tags)
  "( tag... --) Delete multiple tags."

  (dolist (tag (args))
    (gs:delete-tag tag))
  )


; h2. Layout

(gs:init)
(gs:set-trace true)
(gs:set-look-and-feel "javax.swing.plaf.metal.MetalLookAndFeel")

(gs:frame 'main  100 100  800 800  "Story Trace")
(gs:set-border-layout 'main)

(gs:canvas 'main-canvas)
(gs:set-font 'main-canvas "Lucida Sans" 10 "plain")
(gs:set-background 'main-canvas gs:gray)
(gs:draw-text 'label 
              (format "%s - %s" program-name program-version) 
              10 20  '(0.4 0.4 0.4))

(gs:add-to 'main  
	   'main-canvas "center")


; h2. Events
;; (gs:mouse-moved    'main-canvas 'canvas-move true)
(gs:mouse-dragged  'main-canvas 'canvas-drag true)
(gs:mouse-pressed  'main-canvas 'canvas-click true)
(gs:mouse-released 'main-canvas 'canvas-unclick true)


; h2. Handlers

(define (quitting) (exit 0))


; h3. Draw Node

(define (icon tag which x y)
  (gs:draw-image tag (format "i/icon_%s.png" which)  (- x 10) (- y 10)  20 20))

(define (add-halo x y  left right top bottom i)
  (setq left   (- x 40)  right  (+ x 40)
        top    (- y 40)  bottom (+ y 40))

  (icon "ID" "dup"  left top)
  (icon "IX" "x"    right top)
  (icon "IE" "edit" right bottom)
  (icon "IL" "link" x bottom)
  (icon "IM" "move" left bottom)

  (for (i 0 (- (length colours) 1))
       (gs:fill-circle (string "IC" i) (- left (* 20 i)) y 10 (colours i)))
)

(define (remove-halo)
  (gs:delete-tags "IX" "IE" "IM" "ID" "IL"
                  "IC0" "IC1" "IC2" "IC3" "IC4" "IC5")
)


(define (draw-node which n  ink)
  "( which n /ink/ --) Draw specified node."

  (println which " : " n)
  (gs:fill-circle which (n 0) (n 1) 16 (n 2))
  
  (setq ink gs:black)
  (if (= which current) 
      (begin
       (setq ink gs:white)
       (gs:draw-circle which (n 0) (n 1) 16 gs:red)
       (add-halo (n 0) (n 1))))

  (gs:draw-text which  (n 3)  (n 0) (+ (n 1) 4)  ink)
)

(define (refresh-node which)
  (println "refresh-node " which)
  (remove-halo)
  (gs:delete-tag which)
  (draw-node which (nodes which))
)

(define (recolour-node which tag)
  (setq ((nodes which) 2) (colours (int (last tag))))
  (refresh-node which)
)

(define (deleting)
  (remove-halo)
  (gs:delete-tag current)
  (nodes current nil)
  (setq current nil)
)

(define (moving n x y  dx dy)
  (setq dx (- x (gui-start 0))  dy (- y (gui-start 1)))

  (gs:translate-tag n dx dy)
  (setq ((nodes n) 0) (+ ((nodes n) 0) dx)  
        ((nodes n) 1) (+ ((nodes n) 1) dy))
  )


(define (edit-titling)
  (gs:request-focus 'edit-tags))

(define (edit-tagsing)
  (gs:request-focus 'edit-text))

(define (closing-edit widget)
  "( widget --) Save new values from edit window and refresh node."

  (setq ((nodes current) 3) (gs:get-text 'edit-title))
  (setq ((nodes current) 4) (gs:get-text 'edit-tags))
  (setq ((nodes current) 5) (gs:get-text 'edit-text))

  (refresh-node current)
)

(define (show-edit-window n)
  (println "Should show edit window for " n)
  
  (gs:dialog 'main-edit 'main 
	     "edit" 624 800 nil true)
  (gs:set-flow-layout 'main-edit)
  (gs:text-field 'edit-title 'edit-titling 54)
  (gs:text-field 'edit-tags  'edit-tagsing 54)
  (gs:text-area  'edit-text  'gs:nix 598 600)
  (gs:add-to 'main-edit
	     'edit-title 
             'edit-tags  
	     'edit-text  
             )

  (gs:set-text 'edit-title ((nodes n) 3))
  (gs:set-text 'edit-tags  ((nodes n) 4))
  (gs:set-text 'edit-text  ((nodes n) 5))

  (gs:window-closed 'main-edit 'closing-edit)
  (gs:set-visible 'main-edit true)
  )

(define (uncurrent  hold)
  "( /hold/ --) Remove current status from node."

  (if current 
      (begin
       (setq hold current  current nil)
       (remove-halo)
       (gs:delete-tag hold)
       (draw-node hold (nodes hold))
       ))
  )

(define (+node x y)
  (uncurrent)

  (setq current (string "C-" (++ next-id)))
  (setq n (nodes current (list x y '(1 1 1) "Unnamed" "" "")))
  (draw-node current n)
  )

(define (pick-node tag)
  (uncurrent)

  (setq current tag)
  (draw-node current (nodes current))
  )  


(define (new-state state x y)
  "( state x y --) Change to new gui state."

  (println "Changing to state " state ".")

  (setq gui-state state)
  (if (= 'waiting gui-state) 
      (setq gui-start nil)
    (setq gui-start (list x y)))
)


(define (canvas-click x y button modifier tags  n)
  (println "Clicking: " x "x" y ", tags: " tags)
  (if (in "IM" tags) (begin 
                      (remove-halo)
                      (new-state 'moving x y))
    (in "IL" tags) (new-state 'linking ((nodes current) 0) ((nodes current) 1))
    )
)

(define (canvas-drag x y button modifier tags  n)
  (if (= 'moving gui-state) (begin 
                             (moving current x y)
                             (setq gui-start (list x y)))
    (= 'linking gui-state) (begin
                            (gs:delete-tag 'transient)
                            (gs:draw-line 'transient 
                                          (gui-start 0) (gui-start 1)
                                          x y  '(.7 .7 1)))
    )
)

(define (canvas-unclick x y button modifier tags  n)
  ;; Clear old active node.
  (if 
    (= gui-state 'moving) (begin 
                           (moving current x y)
                           (add-halo ((nodes current) 0) ((nodes current) 1)))
    (= gui-state 'linking) (begin
                           (gs:delete-tag 'transient)
                           (println "Linked to: " tags "."))
    (empty? tags) (+node x y)
    (= "IX" (first tags)) (deleting)
    (= "IE" (first tags)) (show-edit-window current)
    (starts-with (first tags) "IC") (recolour-node current (first tags))
    (pick-node (first tags))
    )

  (new-state 'waiting)
  (gs:update)
  )

; Define progam closing action to save current work.

(define (closing)
  (save "nodes.lsp" 'nodes)
  (exit)
  )
(gs:window-closed 'main 'closing)

; Load saved nodes and update next node id.

(load "nodes.lsp")
(dolist (item (nodes))
  (setq next-id (max next-id (int ((parse (item 0) "-") 1))))
  (draw-node (item 0) (item 1))
  )
(setq next-id (++ next-id))

; Show main window and start GUI Server.

(gs:set-visible 'main true)
(gs:listen)
